home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol146 / xlobj.c < prev    next >
Encoding:
C/C++ Source or Header  |  1986-12-16  |  14.5 KB  |  579 lines
  1. /* xlobj - xlisp object functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. #ifdef MEGAMAX
  9. overlay "overflow"
  10. #endif
  11.  
  12. /* external variables */
  13. extern NODE *xlstack,*xlenv;
  14. extern NODE *s_stdout;
  15. extern NODE *self,*msgclass,*msgcls,*class,*object;
  16. extern NODE *new,*isnew;
  17.  
  18. /* instance variable numbers for the class 'Class' */
  19. #define MESSAGES    0    /* list of messages */
  20. #define IVARS        1    /* list of instance variable names */
  21. #define CVARS        2    /* list of class variable names */
  22. #define CVALS        3    /* list of class variable values */
  23. #define SUPERCLASS    4    /* pointer to the superclass */
  24. #define IVARCNT        5    /* number of class instance variables */
  25. #define IVARTOTAL    6    /* total number of instance variables */
  26.  
  27. /* number of instance variables for the class 'Class' */
  28. #define CLASSSIZE    7
  29.  
  30. /* forward declarations */
  31. FORWARD NODE *entermsg();
  32. FORWARD NODE *findmsg();
  33. FORWARD NODE *sendmsg();
  34. FORWARD NODE *findvar();
  35. FORWARD NODE *getivar();
  36. FORWARD NODE *getcvar();
  37. FORWARD NODE *makelist();
  38.  
  39. /* xlgetivar - get the value of an instance variable */
  40. NODE *xlgetivar(obj,num)
  41.   NODE *obj; int num;
  42. {
  43.     return (car(getivar(obj,num)));
  44. }
  45.  
  46. /* xlsetivar - set the value of an instance variable */
  47. xlsetivar(obj,num,val)
  48.   NODE *obj; int num; NODE *val;
  49. {
  50.     rplaca(getivar(obj,num),val);
  51. }
  52.  
  53. /* xlclass - define a class */
  54. NODE *xlclass(name,vcnt)
  55.   char *name; int vcnt;
  56. {
  57.     NODE *sym,*cls;
  58.  
  59.     /* create the class */
  60.     sym = xlsenter(name);
  61.     setvalue(sym,cls = newnode(OBJ));
  62.     cls->n_obclass = class;
  63.     cls->n_obdata = makelist(CLASSSIZE);
  64.  
  65.     /* set the instance variable counts */
  66.     xlsetivar(cls,IVARCNT,cvfixnum((FIXNUM)vcnt));
  67.     xlsetivar(cls,IVARTOTAL,cvfixnum((FIXNUM)vcnt));
  68.  
  69.     /* set the superclass to 'Object' */
  70.     xlsetivar(cls,SUPERCLASS,object);
  71.  
  72.     /* return the new class */
  73.     return (cls);
  74. }
  75.  
  76. /* xladdivar - enter an instance variable */
  77. xladdivar(cls,var)
  78.   NODE *cls; char *var;
  79. {
  80.     NODE *ivar,*lptr;
  81.  
  82.     /* find the 'ivars' instance variable */
  83.     ivar = getivar(cls,IVARS);
  84.  
  85.     /* add the instance variable */
  86.     lptr = newnode(LIST);
  87.     rplacd(lptr,car(ivar));
  88.     rplaca(ivar,lptr);
  89.     rplaca(lptr,xlsenter(var));
  90. }
  91.  
  92. /* xladdmsg - add a message to a class */
  93. xladdmsg(cls,msg,code)
  94.   NODE *cls; char *msg; NODE *(*code)();
  95. {
  96.     NODE *mptr;
  97.  
  98.     /* enter the message selector */
  99.     mptr = entermsg(cls,xlsenter(msg));
  100.  
  101.     /* store the method for this message */
  102.     rplacd(mptr,newnode(SUBR));
  103.     cdr(mptr)->n_subr = code;
  104. }
  105.  
  106. /* xlsend - send a message to an object (message in arg list) */
  107. NODE *xlsend(obj,args)
  108.   NODE *obj,*args;
  109. {
  110.     NODE *oldstk,arglist,*msg,*val;
  111.  
  112.     /* find the message binding for this message */
  113.     if ((msg = findmsg(obj->n_obclass,xlevmatch(SYM,&args))) == NIL)
  114.     xlfail("no method for this message");
  115.  
  116.     /* evaluate the arguments and send the message */
  117.     oldstk = xlsave(&arglist,NULL);
  118.     arglist.n_ptr = xlevlist(args);
  119.     val = sendmsg(obj,msg,arglist.n_ptr);
  120.     xlstack = oldstk;
  121.  
  122.     /* return the result */
  123.     return (val);
  124. }
  125.  
  126. /* xlobgetvalue - get the value of an instance variable */
  127. int xlobgetvalue(sym,pval)
  128.   NODE *sym,**pval;
  129. {
  130.     NODE *bnd;
  131.     if ((bnd = findvar(sym)) == NIL)
  132.     return (FALSE);
  133.     *pval = car(bnd);
  134.     return (TRUE);
  135. }
  136.  
  137. /* xlobsetvalue - set the value of an instance variable */
  138. int xlobsetvalue(sym,val)
  139.   NODE *sym,*val;
  140. {
  141.     NODE *bnd;
  142.     if ((bnd = findvar(sym)) == NIL)
  143.     return (FALSE);
  144.     rplaca(bnd,val);
  145.     return (TRUE);
  146. }
  147.  
  148. /* obisnew - default 'isnew' method */
  149. LOCAL NODE *obisnew(args)
  150.   NODE *args;
  151. {
  152.     xllastarg(args);
  153.     return (xlygetvalue(self));
  154. }
  155.  
  156. /* obclass - get the class of an object */
  157. LOCAL NODE *obclass(args)
  158.   NODE *args;
  159. {
  160.     /* make sure there aren't any arguments */
  161.     xllastarg(args);
  162.  
  163.     /* return the object's class */
  164.     return (xlygetvalue(self)->n_obclass);
  165. }
  166.  
  167. /* obshow - show the instance variables of an object */
  168. LOCAL NODE *obshow(args)
  169.   NODE *args;
  170. {
  171.     NODE *oldstk,fptr,*obj,*cls,*names;
  172.     int ivtotal,n;
  173.  
  174.     /* create a new stack frame */
  175.     oldstk = xlsave(&fptr,NULL);
  176.  
  177.     /* get the file pointer */
  178.     fptr.n_ptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
  179.     xllastarg(args);
  180.  
  181.     /* get the object and its class */
  182.     obj = xlygetvalue(self);
  183.     cls = obj->n_obclass;
  184.  
  185.     /* print the object and class */
  186.     xlputstr(fptr.n_ptr,"Object is ");
  187.     xlprint(fptr.n_ptr,obj,TRUE);
  188.     xlputstr(fptr.n_ptr,", Class is ");
  189.     xlprint(fptr.n_ptr,cls,TRUE);
  190.     xlterpri(fptr.n_ptr);
  191.  
  192.     /* print the object's instance variables */
  193.     for (cls = obj->n_obclass; cls; cls = xlgetivar(cls,SUPERCLASS)) {
  194.     names = xlgetivar(cls,IVARS);
  195.     ivtotal = getivcnt(cls,IVARTOTAL);
  196.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  197.         xlputstr(fptr.n_ptr,"  ");
  198.         xlprint(fptr.n_ptr,car(names),TRUE);
  199.         xlputstr(fptr.n_ptr," = ");
  200.         xlprint(fptr.n_ptr,xlgetivar(obj,n),TRUE);
  201.         xlterpri(fptr.n_ptr);
  202.         names = cdr(names);
  203.     }
  204.     }
  205.  
  206.     /* restore the previous stack frame */
  207.     xlstack = oldstk;
  208.  
  209.     /* return the object */
  210.     return (obj);
  211. }
  212.  
  213. /* obsendsuper - send a message to an object's superclass */
  214. LOCAL NODE *obsendsuper(args)
  215.   NODE *args;
  216. {
  217.     NODE *obj,*super,*msg;
  218.  
  219.     /* get the object */
  220.     obj = xlygetvalue(self);
  221.  
  222.     /* get the object's superclass */
  223.     super = xlgetivar(obj->n_obclass,SUPERCLASS);
  224.  
  225.     /* find the message binding for this message */
  226.     if ((msg = findmsg(super,xlmatch(SYM,&args))) == NIL)
  227.     xlfail("no method for this message");
  228.  
  229.     /* send the message */
  230.     return (sendmsg(obj,msg,args));
  231. }
  232.  
  233. /* clnew - create a new object instance */
  234. LOCAL NODE *clnew()
  235. {
  236.     NODE *oldstk,obj,*cls;
  237.  
  238.     /* create a new stack frame */
  239.     oldstk = xlsave(&obj,NULL);
  240.  
  241.     /* get the class */
  242.     cls = xlygetvalue(self);
  243.  
  244.     /* generate a new object */
  245.     obj.n_ptr = newnode(OBJ);
  246.     obj.n_ptr->n_obclass = cls;
  247.     obj.n_ptr->n_obdata = makelist(getivcnt(cls,IVARTOTAL));
  248.  
  249.     /* restore the previous stack frame */
  250.     xlstack = oldstk;
  251.  
  252.     /* return the new object */
  253.     return (obj.n_ptr);
  254. }
  255.  
  256. /* clisnew - initialize a new class */
  257. LOCAL NODE *clisnew(args)
  258.   NODE *args;
  259. {
  260.     NODE *ivars,*cvars,*super,*cls;
  261.     int n;
  262.  
  263.     /* get the ivars, cvars and superclass */
  264.     ivars = xlmatch(LIST,&args);
  265.     cvars = (args ? xlmatch(LIST,&args) : NIL);
  266.     super = (args ? xlmatch(OBJ,&args) : object);
  267.     xllastarg(args);
  268.  
  269.     /* get the new class object */
  270.     cls = xlygetvalue(self);
  271.  
  272.     /* store the instance and class variable lists and the superclass */
  273.     xlsetivar(cls,IVARS,ivars);
  274.     xlsetivar(cls,CVARS,cvars);
  275.     xlsetivar(cls,CVALS,makelist(listlength(cvars)));
  276.     xlsetivar(cls,SUPERCLASS,super);
  277.  
  278.     /* compute the instance variable count */
  279.     n = listlength(ivars);
  280.     xlsetivar(cls,IVARCNT,cvfixnum((FIXNUM)n));
  281.     n += getivcnt(super,IVARTOTAL);
  282.     xlsetivar(cls,IVARTOTAL,cvfixnum((FIXNUM)n));
  283.  
  284.     /* return the new class object */
  285.     return (cls);
  286. }
  287.  
  288. /* clanswer - define a method for answering a message */
  289. LOCAL NODE *clanswer(args)
  290.   NODE *args;
  291. {
  292.     NODE *oldstk,arg,msg,fargs,code;
  293.     NODE *obj,*mptr,*fptr;
  294.  
  295.     /* create a new stack frame */
  296.     oldstk = xlsave(&arg,&msg,&fargs,&code,NULL);
  297.  
  298.     /* initialize */
  299.     arg.n_ptr = args;
  300.  
  301.     /* message symbol, formal argument list and code */
  302.     msg.n_ptr = xlmatch(SYM,&arg.n_ptr);
  303.     fargs.n_ptr = xlmatch(LIST,&arg.n_ptr);
  304.     code.n_ptr = xlmatch(LIST,&arg.n_ptr);
  305.     xllastarg(arg.n_ptr);
  306.  
  307.     /* get the object node */
  308.     obj = xlygetvalue(self);
  309.  
  310.     /* make a new message list entry */
  311.     mptr = entermsg(obj,msg.n_ptr);
  312.  
  313.     /* setup the message node */
  314.     rplacd(mptr,fptr = newnode(LIST));
  315.     rplaca(fptr,fargs.n_ptr);
  316.     rplacd(fptr,code.n_ptr);
  317.  
  318.     /* restore the previous stack frame */
  319.     xlstack = oldstk;
  320.  
  321.     /* return the object */
  322.     return (obj);
  323. }
  324.  
  325. /* entermsg - add a message to a class */
  326. LOCAL NODE *entermsg(cls,msg)
  327.   NODE *cls,*msg;
  328. {
  329.     NODE *ivar,*lptr,*mptr;
  330.  
  331.     /* find the 'messages' instance variable */
  332.     ivar = getivar(cls,MESSAGES);
  333.  
  334.     /* lookup the message */
  335.     for (lptr = car(ivar); lptr != NIL; lptr = cdr(lptr))
  336.     if (car(mptr = car(lptr)) == msg)
  337.         return (mptr);
  338.  
  339.     /* allocate a new message entry if one wasn't found */
  340.     lptr = newnode(LIST);
  341.     rplacd(lptr,car(ivar));
  342.     rplaca(ivar,lptr);
  343.     rplaca(lptr,mptr = newnode(LIST));
  344.     rplaca(mptr,msg);
  345.  
  346.     /* return the symbol node */
  347.     return (mptr);
  348. }
  349.  
  350. /* findmsg - find the message binding given an object and a class */
  351. LOCAL NODE *findmsg(cls,sym)
  352.   NODE *cls,*sym;
  353. {
  354.     NODE *lptr,*msg;
  355.  
  356.     /* look for the message in the class or superclasses */
  357.     for (msgcls = cls; msgcls != NIL; ) {
  358.  
  359.     /* lookup the message in this class */
  360.     for (lptr = xlgetivar(msgcls,MESSAGES); lptr != NIL; lptr = cdr(lptr))
  361.         if ((msg = car(lptr)) != NIL && car(msg) == sym)
  362.         return (msg);
  363.  
  364.     /* look in class's superclass */
  365.     msgcls = xlgetivar(msgcls,SUPERCLASS);
  366.     }
  367.  
  368.     /* message not found */
  369.     return (NIL);
  370. }
  371.  
  372. /* sendmsg - send a message to an object */
  373. LOCAL NODE *sendmsg(obj,msg,args)
  374.   NODE *obj,*msg,*args;
  375. {
  376.     NODE *oldstk,oldenv,newenv,method,cptr,val,*isnewmsg;
  377.  
  378.     /* create a new stack frame */
  379.     oldstk = xlsave(&oldenv,&newenv,&method,&cptr,&val,NULL);
  380.  
  381.     /* get the method for this message */
  382.     method.n_ptr = cdr(msg);
  383.  
  384.     /* make sure its a function or a subr */
  385.     if (!subrp(method.n_ptr) && !consp(method.n_ptr))
  386.     xlfail("bad method");
  387.  
  388.     /* create a new environment frame */
  389.     newenv.n_ptr = xlframe(NIL);
  390.     oldenv.n_ptr = xlenv;
  391.  
  392.     /* bind the symbols 'self' and 'msgclass' */
  393.     xlbind(self,obj,newenv.n_ptr);
  394.     xlbind(msgclass,msgcls,newenv.n_ptr);
  395.  
  396.     /* evaluate the function call */
  397.     if (subrp(method.n_ptr)) {
  398.     xlenv = newenv.n_ptr;
  399.     val.n_ptr = (*method.n_ptr->n_subr)(args);
  400.     }
  401.     else {
  402.  
  403.     /* bind the formal arguments */
  404.     xlabind(car(method.n_ptr),args,newenv.n_ptr);
  405.     xlenv = newenv.n_ptr;
  406.  
  407.     /* execute the code */
  408.     cptr.n_ptr = cdr(method.n_ptr);
  409.     while (cptr.n_ptr != NIL)
  410.         val.n_ptr = xlevarg(&cptr.n_ptr);
  411.     }
  412.  
  413.     /* restore the environment */
  414.     xlenv = oldenv.n_ptr;
  415.  
  416.     /* after creating an object, send it the "isnew" message */
  417.     if (car(msg) == new && val.n_ptr != NIL) {
  418.     if ((isnewmsg = findmsg(val.n_ptr->n_obclass,isnew)) == NIL)
  419.         xlfail("no method for the isnew message");
  420.     sendmsg(val.n_ptr,isnewmsg,args);
  421.     }
  422.  
  423.     /* restore the previous stack frame */
  424.     xlstack = oldstk;
  425.  
  426.     /* return the result value */
  427.     return (val.n_ptr);
  428. }
  429.  
  430. /* getivcnt - get the number of instance variables for a class */
  431. LOCAL int getivcnt(cls,ivar)
  432.   NODE *cls; int ivar;
  433. {
  434.     NODE *cnt;
  435.     if ((cnt = xlgetivar(cls,ivar)) == NIL || !fixp(cnt))
  436.     xlfail("bad value for instance variable count");
  437.     return ((int)cnt->n_int);
  438. }
  439.  
  440. /* findvar - find a class or instance variable */
  441. LOCAL NODE *findvar(sym)
  442.   NODE *sym;
  443. {
  444.     NODE *obj,*cls,*names;
  445.     int ivtotal,n;
  446.  
  447.     /* get the current object and the message class */
  448.     obj = xlygetvalue(self);
  449.     cls = xlygetvalue(msgclass);
  450.     if (!(objectp(obj) && objectp(cls)))
  451.     return (NIL);
  452.  
  453.     /* find the instance or class variable */
  454.     for (; objectp(cls); cls = xlgetivar(cls,SUPERCLASS)) {
  455.  
  456.     /* check the instance variables */
  457.     names = xlgetivar(cls,IVARS);
  458.     ivtotal = getivcnt(cls,IVARTOTAL);
  459.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  460.         if (car(names) == sym)
  461.         return (getivar(obj,n));
  462.         names = cdr(names);
  463.     }
  464.  
  465.     /* check the class variables */
  466.     names = xlgetivar(cls,CVARS);
  467.     for (n = 0; consp(names); ++n) {
  468.         if (car(names) == sym)
  469.         return (getcvar(cls,n));
  470.         names = cdr(names);
  471.     }
  472.     }
  473.  
  474.     /* variable not found */
  475.     return (NIL);
  476. }
  477.  
  478. /* getivar - get an instance variable */
  479. LOCAL NODE *getivar(obj,num)
  480.   NODE *obj; int num;
  481. {
  482.     NODE *ivar;
  483.  
  484.     /* get the instance variable */
  485.     for (ivar = obj->n_obdata; num > 0; num--)
  486.     if (ivar != NIL)
  487.         ivar = cdr(ivar);
  488.     else
  489.         xlfail("bad instance variable list");
  490.  
  491.     /* return the instance variable */
  492.     return (ivar);
  493. }
  494.  
  495. /* getcvar - get a class variable */
  496. LOCAL NODE *getcvar(cls,num)
  497.   NODE *cls; int num;
  498. {
  499.     NODE *cvar;
  500.  
  501.     /* get the class variable */
  502.     for (cvar = xlgetivar(cls,CVALS); num > 0; num--)
  503.     if (cvar != NIL)
  504.         cvar = cdr(cvar);
  505.     else
  506.         xlfail("bad class variable list");
  507.  
  508.     /* return the class variable */
  509.     return (cvar);
  510. }
  511.  
  512. /* listlength - find the length of a list */
  513. LOCAL int listlength(list)
  514.   NODE *list;
  515. {
  516.     int len;
  517.     for (len = 0; consp(list); len++)
  518.     list = cdr(list);
  519.     return (len);
  520. }
  521.  
  522. /* makelist - make a list of nodes */
  523. LOCAL NODE *makelist(cnt)
  524.   int cnt;
  525. {
  526.     NODE *oldstk,list,*lnew;
  527.  
  528.     /* make the list */
  529.     oldstk = xlsave(&list,NULL);
  530.     for (; cnt > 0; cnt--) {
  531.     lnew = newnode(LIST);
  532.     rplacd(lnew,list.n_ptr);
  533.     list.n_ptr = lnew;
  534.     }
  535.     xlstack = oldstk;
  536.  
  537.     /* return the list */
  538.     return (list.n_ptr);
  539. }
  540.  
  541. /* xloinit - object function initialization routine */
  542. xloinit()
  543. {
  544.     /* don't confuse the garbage collector */
  545.     class = object = NIL;
  546.  
  547.     /* enter the object related symbols */
  548.     self    = xlsenter("SELF");
  549.     msgclass    = xlsenter("MSGCLASS");
  550.     new        = xlsenter(":NEW");
  551.     isnew    = xlsenter(":ISNEW");
  552.  
  553.     /* create the 'Class' object */
  554.     class = xlclass("CLASS",CLASSSIZE);
  555.     class->n_obclass = class;
  556.  
  557.     /* create the 'Object' object */
  558.     object = xlclass("OBJECT",0);
  559.  
  560.     /* finish initializing 'class' */
  561.     xlsetivar(class,SUPERCLASS,object);
  562.     xladdivar(class,"IVARTOTAL");    /* ivar number 6 */
  563.     xladdivar(class,"IVARCNT");        /* ivar number 5 */
  564.     xladdivar(class,"SUPERCLASS");    /* ivar number 4 */
  565.     xladdivar(class,"CVALS");        /* ivar number 3 */
  566.     xladdivar(class,"CVARS");        /* ivar number 2 */
  567.     xladdivar(class,"IVARS");        /* ivar number 1 */
  568.     xladdivar(class,"MESSAGES");    /* ivar number 0 */
  569.     xladdmsg(class,":NEW",clnew);
  570.     xladdmsg(class,":ISNEW",clisnew);
  571.     xladdmsg(class,":ANSWER",clanswer);
  572.  
  573.     /* finish initializing 'object' */
  574.     xladdmsg(object,":ISNEW",obisnew);
  575.     xladdmsg(object,":CLASS",obclass);
  576.     xladdmsg(object,":SHOW",obshow);
  577.     xladdmsg(object,":SENDSUPER",obsendsuper);
  578. }
  579.